home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / C / Applications / Tcl-Tk 8.0 / Pre-installed version / tcl8.0 / tests / proc-old.test < prev    next >
Encoding:
Text File  |  1997-08-15  |  14.3 KB  |  506 lines  |  [TEXT/ALFA]
  1. # Commands covered:  proc, return, global
  2. #
  3. # This file, proc-old.test, includes the original set of tests for Tcl's
  4. # proc, return, and global commands. There is now a new file proc.test
  5. # that contains tests for the tclProc.c source file.
  6. #
  7. # Sourcing this file into Tcl runs the tests and generates output for
  8. # errors.  No output means no errors were found.
  9. #
  10. # Copyright (c) 1991-1993 The Regents of the University of California.
  11. # Copyright (c) 1994-1997 Sun Microsystems, Inc.
  12. #
  13. # See the file "license.terms" for information on usage and redistribution
  14. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  15. #
  16. # SCCS: @(#) proc-old.test 1.31 97/07/02 16:41:36
  17.  
  18. if {[string compare test [info procs test]] == 1} then {source defs}
  19.  
  20. catch {rename t1 ""}
  21. catch {rename foo ""}
  22.  
  23. proc tproc {} {return a; return b}
  24. test proc-old-1.1 {simple procedure call and return} {tproc} a
  25. proc tproc x {
  26.     set x [expr $x+1]
  27.     return $x
  28. }
  29. test proc-old-1.2 {simple procedure call and return} {tproc 2} 3
  30. test proc-old-1.3 {simple procedure call and return} {
  31.     proc tproc {} {return foo}
  32. } {}
  33. test proc-old-1.4 {simple procedure call and return} {
  34.     proc tproc {} {return}
  35.     tproc
  36. } {}
  37. proc tproc1 {a}   {incr a; return $a}
  38. proc tproc2 {a b} {incr a; return $a}
  39. test proc-old-1.5 {simple procedure call and return (2 procs with same body but different parameters)} {
  40.     list [tproc1 123] [tproc2 456 789]
  41. } {124 457}
  42. test proc-old-1.6 {simple procedure call and return (shared proc body string)} {
  43.     set x {}
  44.     proc tproc {} {}   ;# body is shared with x
  45.     list [tproc] [append x foo]
  46. } {{} foo}
  47.  
  48. test proc-old-2.1 {local and global variables} {
  49.     proc tproc x {
  50.     set x [expr $x+1]
  51.     return $x
  52.     }
  53.     set x 42
  54.     list [tproc 6] $x
  55. } {7 42}
  56. test proc-old-2.2 {local and global variables} {
  57.     proc tproc x {
  58.     set y [expr $x+1]
  59.     return $y
  60.     }
  61.     set y 18
  62.     list [tproc 6] $y
  63. } {7 18}
  64. test proc-old-2.3 {local and global variables} {
  65.     proc tproc x {
  66.     global y
  67.     set y [expr $x+1]
  68.     return $y
  69.     }
  70.     set y 189
  71.     list [tproc 6] $y
  72. } {7 7}
  73. test proc-old-2.4 {local and global variables} {
  74.     proc tproc x {
  75.     global y
  76.     return [expr $x+$y]
  77.     }
  78.     set y 189
  79.     list [tproc 6] $y
  80. } {195 189}
  81. catch {unset _undefined_}
  82. test proc-old-2.5 {local and global variables} {
  83.     proc tproc x {
  84.     global _undefined_
  85.     return $_undefined_
  86.     }
  87.     list [catch {tproc xxx} msg] $msg
  88. } {1 {can't read "_undefined_": no such variable}}
  89. test proc-old-2.6 {local and global variables} {
  90.     set a 114
  91.     set b 115
  92.     global a b
  93.     list $a $b
  94. } {114 115}
  95.  
  96. proc do {cmd} {eval $cmd}
  97. test proc-old-3.1 {local and global arrays} {
  98.     catch {unset a}
  99.     set a(0) 22
  100.     list [catch {do {global a; set a(0)}} msg] $msg
  101. } {0 22}
  102. test proc-old-3.2 {local and global arrays} {
  103.     catch {unset a}
  104.     set a(x) 22
  105.     list [catch {do {global a; set a(x) newValue}} msg] $msg $a(x)
  106. } {0 newValue newValue}
  107. test proc-old-3.3 {local and global arrays} {
  108.     catch {unset a}
  109.     set a(x) 22
  110.     set a(y) 33
  111.     list [catch {do {global a; unset a(y)}; array names a} msg] $msg
  112. } {0 x}
  113. test proc-old-3.4 {local and global arrays} {
  114.     catch {unset a}
  115.     set a(x) 22
  116.     set a(y) 33
  117.     list [catch {do {global a; unset a; info exists a}} msg] $msg \
  118.         [info exists a]
  119. } {0 0 0}
  120. test proc-old-3.5 {local and global arrays} {
  121.     catch {unset a}
  122.     set a(x) 22
  123.     set a(y) 33
  124.     list [catch {do {global a; unset a(y); array names a}} msg] $msg
  125. } {0 x}
  126. catch {unset a}
  127. test proc-old-3.6 {local and global arrays} {
  128.     catch {unset a}
  129.     set a(x) 22
  130.     set a(y) 33
  131.     do {global a; do {global a; unset a}; set a(z) 22}
  132.     list [catch {array names a} msg] $msg
  133. } {0 z}
  134. test proc-old-3.7 {local and global arrays} {
  135.     proc t1 {args} {global info; set info 1}
  136.     catch {unset a}
  137.     set info {}
  138.     do {global a; trace var a(1) w t1}
  139.     set a(1) 44
  140.     set info
  141. } 1
  142. test proc-old-3.8 {local and global arrays} {
  143.     proc t1 {args} {global info; set info 1}
  144.     catch {unset a}
  145.     trace var a(1) w t1
  146.     set info {}
  147.     do {global a; trace vdelete a(1) w t1}
  148.     set a(1) 44
  149.     set info
  150. } {}
  151. test proc-old-3.9 {local and global arrays} {
  152.     proc t1 {args} {global info; set info 1}
  153.     catch {unset a}
  154.     trace var a(1) w t1
  155.     do {global a; trace vinfo a(1)}
  156. } {{w t1}}
  157. catch {unset a}
  158.  
  159. test proc-old-3.1 {arguments and defaults} {
  160.     proc tproc {x y z} {
  161.     return [list $x $y $z]
  162.     }
  163.     tproc 11 12 13
  164. } {11 12 13}
  165. test proc-old-3.2 {arguments and defaults} {
  166.     proc tproc {x y z} {
  167.     return [list $x $y $z]
  168.     }
  169.     list [catch {tproc 11 12} msg] $msg
  170. } {1 {no value given for parameter "z" to "tproc"}}
  171. test proc-old-3.3 {arguments and defaults} {
  172.     proc tproc {x y z} {
  173.     return [list $x $y $z]
  174.     }
  175.     list [catch {tproc 11 12 13 14} msg] $msg
  176. } {1 {called "tproc" with too many arguments}}
  177. test proc-old-3.4 {arguments and defaults} {
  178.     proc tproc {x {y y-default} {z z-default}} {
  179.     return [list $x $y $z]
  180.     }
  181.     tproc 11 12 13
  182. } {11 12 13}
  183. test proc-old-3.5 {arguments and defaults} {
  184.     proc tproc {x {y y-default} {z z-default}} {
  185.     return [list $x $y $z]
  186.     }
  187.     tproc 11 12
  188. } {11 12 z-default}
  189. test proc-old-3.6 {arguments and defaults} {
  190.     proc tproc {x {y y-default} {z z-default}} {
  191.     return [list $x $y $z]
  192.     }
  193.     tproc 11
  194. } {11 y-default z-default}
  195. test proc-old-3.7 {arguments and defaults} {
  196.     proc tproc {x {y y-default} {z z-default}} {
  197.     return [list $x $y $z]
  198.     }
  199.     list [catch {tproc} msg] $msg
  200. } {1 {no value given for parameter "x" to "tproc"}}
  201. test proc-old-3.8 {arguments and defaults} {
  202.     list [catch {
  203.     proc tproc {x {y y-default} z} {
  204.         return [list $x $y $z]
  205.     }
  206.     tproc 2 3
  207.     } msg] $msg
  208. } {1 {no value given for parameter "z" to "tproc"}}
  209. test proc-old-3.9 {arguments and defaults} {
  210.     proc tproc {x {y y-default} args} {
  211.     return [list $x $y $args]
  212.     }
  213.     tproc 2 3 4 5
  214. } {2 3 {4 5}}
  215. test proc-old-3.10 {arguments and defaults} {
  216.     proc tproc {x {y y-default} args} {
  217.     return [list $x $y $args]
  218.     }
  219.     tproc 2 3
  220. } {2 3 {}}
  221. test proc-old-3.11 {arguments and defaults} {
  222.     proc tproc {x {y y-default} args} {
  223.     return [list $x $y $args]
  224.     }
  225.     tproc 2
  226. } {2 y-default {}}
  227. test proc-old-3.12 {arguments and defaults} {
  228.     proc tproc {x {y y-default} args} {
  229.     return [list $x $y $args]
  230.     }
  231.     list [catch {tproc} msg] $msg
  232. } {1 {no value given for parameter "x" to "tproc"}}
  233.  
  234. test proc-old-4.1 {variable numbers of arguments} {
  235.     proc tproc args {return $args}
  236.     tproc
  237. } {}
  238. test proc-old-4.2 {variable numbers of arguments} {
  239.     proc tproc args {return $args}
  240.     tproc 1 2 3 4 5 6 7 8
  241. } {1 2 3 4 5 6 7 8}
  242. test proc-old-4.3 {variable numbers of arguments} {
  243.     proc tproc args {return $args}
  244.     tproc 1 {2 3} {4 {5 6} {{{7}}}} 8
  245. } {1 {2 3} {4 {5 6} {{{7}}}} 8}
  246. test proc-old-4.4 {variable numbers of arguments} {
  247.     proc tproc {x y args} {return $args}
  248.     tproc 1 2 3 4 5 6 7
  249. } {3 4 5 6 7}
  250. test proc-old-4.5 {variable numbers of arguments} {
  251.     proc tproc {x y args} {return $args}
  252.     tproc 1 2
  253. } {}
  254. test proc-old-4.6 {variable numbers of arguments} {
  255.     proc tproc {x missing args} {return $args}
  256.     list [catch {tproc 1} msg] $msg
  257. } {1 {no value given for parameter "missing" to "tproc"}}
  258.  
  259. test proc-old-5.1 {error conditions} {
  260.     list [catch {proc} msg] $msg
  261. } {1 {wrong # args: should be "proc name args body"}}
  262. test proc-old-5.2 {error conditions} {
  263.     list [catch {proc tproc b} msg] $msg
  264. } {1 {wrong # args: should be "proc name args body"}}
  265. test proc-old-5.3 {error conditions} {
  266.     list [catch {proc tproc b c d e} msg] $msg
  267. } {1 {wrong # args: should be "proc name args body"}}
  268. test proc-old-5.4 {error conditions} {
  269.     list [catch {proc tproc \{xyz {return foo}} msg] $msg
  270. } {1 {unmatched open brace in list}}
  271. test proc-old-5.5 {error conditions} {
  272.     list [catch {proc tproc {{} y} {return foo}} msg] $msg
  273. } {1 {procedure "tproc" has argument with no name}}
  274. test proc-old-5.6 {error conditions} {
  275.     list [catch {proc tproc {{} y} {return foo}} msg] $msg
  276. } {1 {procedure "tproc" has argument with no name}}
  277. test proc-old-5.7 {error conditions} {
  278.     list [catch {proc tproc {{x 1 2} y} {return foo}} msg] $msg
  279. } {1 {too many fields in argument specifier "x 1 2"}}
  280. test proc-old-5.8 {error conditions} {
  281.     catch {return}
  282. } 2
  283. test proc-old-5.9 {error conditions} {
  284.     list [catch {global} msg] $msg
  285. } {1 {wrong # args: should be "global varName ?varName ...?"}}
  286. proc tproc {} {
  287.     set a 22
  288.     global a
  289. }
  290. test proc-old-5.10 {error conditions} {
  291.     list [catch {tproc} msg] $msg
  292. } {1 {variable "a" already exists}}
  293. test proc-old-5.11 {error conditions} {
  294.     catch {rename tproc {}}
  295.     catch {
  296.     proc tproc {x {} z} {return foo}
  297.     }
  298.     list [catch {tproc 1} msg] $msg
  299. } {1 {invalid command name "tproc"}}
  300. test proc-old-5.12 {error conditions} {
  301.     proc tproc {} {
  302.     set a 22
  303.     error "error in procedure"
  304.     return
  305.     }
  306.     list [catch tproc msg] $msg
  307. } {1 {error in procedure}}
  308. test proc-old-5.13 {error conditions} {
  309.     proc tproc {} {
  310.     set a 22
  311.     error "error in procedure"
  312.     return
  313.     }
  314.     catch tproc msg
  315.     set errorInfo
  316. } {error in procedure
  317.     while executing
  318. "error "error in procedure""
  319.     (procedure "tproc" line 3)
  320.     invoked from within
  321. "tproc"}
  322. test proc-old-5.14 {error conditions} {
  323.     proc tproc {} {
  324.     set a 22
  325.     break
  326.     return
  327.     }
  328.     catch tproc msg
  329.     set errorInfo
  330. } {invoked "break" outside of a loop
  331.     while executing
  332. "tproc"}
  333. test proc-old-5.15 {error conditions} {
  334.     proc tproc {} {
  335.     set a 22
  336.     continue
  337.     return
  338.     }
  339.     catch tproc msg
  340.     set errorInfo
  341. } {invoked "continue" outside of a loop
  342.     while executing
  343. "tproc"}
  344. test proc-old-5.16 {error conditions} {
  345.     proc foo args {
  346.     global fooMsg
  347.     set fooMsg "foo was called: $args"
  348.     }
  349.     proc tproc {} {
  350.     set x 44
  351.     trace var x u foo
  352.     while {$x < 100} {
  353.         error "Nested error"
  354.     }
  355.     }
  356.     set fooMsg "foo not called"
  357.     list [catch tproc msg] $msg $errorInfo $fooMsg
  358. } {1 {Nested error} {Nested error
  359.     while executing
  360. "error "Nested error""
  361.     (procedure "tproc" line 5)
  362.     invoked from within
  363. "tproc"} {foo was called: x {} u}}
  364.  
  365. # The tests below will really only be useful when run under Purify or
  366. # some other system that can detect accesses to freed memory...
  367.  
  368. test proc-old-6.1 {procedure that redefines itself} {
  369.     proc tproc {} {
  370.     proc tproc {} {
  371.         return 44
  372.     }
  373.     return 45
  374.     }
  375.     tproc
  376. } 45
  377. test proc-old-6.2 {procedure that deletes itself} {
  378.     proc tproc {} {
  379.     rename tproc {}
  380.     return 45
  381.     }
  382.     tproc
  383. } 45
  384.  
  385. proc tproc code {
  386.     return -code $code abc
  387. }
  388. test proc-old-7.1 {return with special completion code} {
  389.     list [catch {tproc ok} msg] $msg
  390. } {0 abc}
  391. test proc-old-7.2 {return with special completion code} {
  392.     list [catch {tproc error} msg] $msg $errorInfo $errorCode
  393. } {1 abc {abc
  394.     while executing
  395. "tproc error"} NONE}
  396. test proc-old-7.3 {return with special completion code} {
  397.     list [catch {tproc return} msg] $msg
  398. } {2 abc}
  399. test proc-old-7.4 {return with special completion code} {
  400.     list [catch {tproc break} msg] $msg
  401. } {3 abc}
  402. test proc-old-7.5 {return with special completion code} {
  403.     list [catch {tproc continue} msg] $msg
  404. } {4 abc}
  405. test proc-old-7.6 {return with special completion code} {
  406.     list [catch {tproc -14} msg] $msg
  407. } {-14 abc}
  408. test proc-old-7.7 {return with special completion code} {
  409.     list [catch {tproc gorp} msg] $msg
  410. } {1 {bad completion code "gorp": must be ok, error, return, break, continue, or an integer}}
  411. test proc-old-7.8 {return with special completion code} {
  412.     list [catch {tproc 10b} msg] $msg
  413. } {1 {bad completion code "10b": must be ok, error, return, break, continue, or an integer}}
  414. test proc-old-7.9 {return with special completion code} {
  415.     proc tproc2 {} {
  416.     tproc return
  417.     }
  418.     list [catch tproc2 msg] $msg
  419. } {0 abc}
  420. test proc-old-7.10 {return with special completion code} {
  421.     proc tproc2 {} {
  422.     return -code error
  423.     }
  424.     list [catch tproc2 msg] $msg
  425. } {1 {}}
  426. test proc-old-7.11 {return with special completion code} {
  427.     proc tproc2 {} {
  428.     global errorCode errorInfo
  429.     catch {open _bad_file_name r} msg
  430.     return -code error -errorinfo $errorInfo -errorcode $errorCode $msg
  431.     }
  432.     normalizeMsg [list [catch tproc2 msg] $msg $errorInfo $errorCode]
  433. } {1 {couldn't open "_bad_file_name": no such file or directory} {couldn't open "_bad_file_name": no such file or directory
  434.     while executing
  435. "open _bad_file_name r"
  436.     invoked from within
  437. "tproc2"} {posix enoent {no such file or directory}}}
  438. test proc-old-7.12 {return with special completion code} {
  439.     proc tproc2 {} {
  440.     global errorCode errorInfo
  441.     catch {open _bad_file_name r} msg
  442.     return -code error -errorcode $errorCode $msg
  443.     }
  444.     normalizeMsg [list [catch tproc2 msg] $msg $errorInfo $errorCode]
  445. } {1 {couldn't open "_bad_file_name": no such file or directory} {couldn't open "_bad_file_name": no such file or directory
  446.     while executing
  447. "tproc2"} {posix enoent {no such file or directory}}}
  448. test proc-old-7.13 {return with special completion code} {
  449.     proc tproc2 {} {
  450.     global errorCode errorInfo
  451.     catch {open _bad_file_name r} msg
  452.     return -code error -errorinfo $errorInfo $msg
  453.     }
  454.     normalizeMsg [list [catch tproc2 msg] $msg $errorInfo $errorCode]
  455. } {1 {couldn't open "_bad_file_name": no such file or directory} {couldn't open "_bad_file_name": no such file or directory
  456.     while executing
  457. "open _bad_file_name r"
  458.     invoked from within
  459. "tproc2"} none}
  460. test proc-old-7.14 {return with special completion code} {
  461.     proc tproc2 {} {
  462.     global errorCode errorInfo
  463.     catch {open _bad_file_name r} msg
  464.     return -code error $msg
  465.     }
  466.     normalizeMsg [list [catch tproc2 msg] $msg $errorInfo $errorCode]
  467. } {1 {couldn't open "_bad_file_name": no such file or directory} {couldn't open "_bad_file_name": no such file or directory
  468.     while executing
  469. "tproc2"} none}
  470. test proc-old-7.14 {return with special completion code} {
  471.     list [catch {return -badOption foo message} msg] $msg
  472. } {1 {bad option "-badOption": must be -code, -errorcode, or -errorinfo}}
  473.  
  474. test proc-old-8.1 {unset and undefined local arrays} {
  475.     proc t1 {} {
  476.         foreach v {xxx, yyy} {
  477.             catch {unset $v}
  478.         }
  479.         set yyy(foo) bar
  480.     }
  481.     t1
  482. } bar
  483.  
  484. test proc-old-9.1 {empty command name} {
  485.     catch {rename {} ""}
  486.     proc t1 {args} {
  487.         return
  488.     }
  489.     set v [t1]
  490.     catch {$v}
  491. } 1
  492.  
  493. test proc-old-10.1 {ByteCode epoch change during recursive proc execution} {
  494.     proc t1 x {
  495.         set y 20
  496.         rename expr expr.old
  497.         rename expr.old expr
  498.         if $x then {t1 0} ;# recursive call after foo's code is invalidated
  499.         return 20
  500.     }
  501.     t1 1
  502. } 20
  503.  
  504. catch {rename t1 ""}
  505. catch {rename foo ""}
  506.